home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / util.c < prev    next >
C/C++ Source or Header  |  1998-07-20  |  66KB  |  2,888 lines
  1. /*    util.c
  2.  *
  3.  *    Copyright (c) 1991-1997, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  */
  9.  
  10. /*
  11.  * "Very useful, no doubt, that was to Saruman; yet it seems that he was
  12.  * not content."  --Gandalf
  13.  */
  14.  
  15. #include "EXTERN.h"
  16. #include "perl.h"
  17.  
  18. #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  19. #include <signal.h>
  20. #endif
  21.  
  22. #ifndef SIG_ERR
  23. # define SIG_ERR ((Sighandler_t) -1)
  24. #endif
  25.  
  26. /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  27. #ifdef I_UNISTD
  28. #  include <unistd.h>
  29. #endif
  30.  
  31. #ifdef I_VFORK
  32. #  include <vfork.h>
  33. #endif
  34.  
  35. /* Put this after #includes because fork and vfork prototypes may
  36.    conflict.
  37. */
  38. #ifndef HAS_VFORK
  39. #   define vfork fork
  40. #endif
  41.  
  42. #ifdef I_FCNTL
  43. #  include <fcntl.h>
  44. #endif
  45. #ifdef I_SYS_FILE
  46. #  include <sys/file.h>
  47. #endif
  48.  
  49. #ifdef I_SYS_WAIT
  50. #  include <sys/wait.h>
  51. #endif
  52.  
  53. #define FLUSH
  54.  
  55. #ifdef LEAKTEST
  56.  
  57. static void xstat _((int));
  58. long xcount[MAXXCOUNT];
  59. long lastxcount[MAXXCOUNT];
  60. long xycount[MAXXCOUNT][MAXYCOUNT];
  61. long lastxycount[MAXXCOUNT][MAXYCOUNT];
  62.  
  63. #endif
  64.  
  65. #ifndef MYMALLOC
  66.  
  67. /* paranoid version of malloc */
  68.  
  69. /* NOTE:  Do not call the next three routines directly.  Use the macros
  70.  * in handy.h, so that we can easily redefine everything to do tracking of
  71.  * allocated hunks back to the original New to track down any memory leaks.
  72.  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  73.  */
  74.  
  75. Malloc_t
  76. safemalloc(MEM_SIZE size)
  77. {
  78.     Malloc_t ptr;
  79. #ifdef HAS_64K_LIMIT
  80.     if (size > 0xffff) {
  81.         PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH;
  82.         my_exit(1);
  83.     }
  84. #endif /* HAS_64K_LIMIT */
  85. #ifdef DEBUGGING
  86.     if ((long)size < 0)
  87.     croak("panic: malloc");
  88. #endif
  89.     ptr = PerlMem_malloc(size?size:1);    /* malloc(0) is NASTY on our system */
  90. #if !(defined(I286) || defined(atarist))
  91.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
  92. #else
  93.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
  94. #endif
  95.     if (ptr != Nullch)
  96.     return ptr;
  97.     else if (PL_nomemok)
  98.     return Nullch;
  99.     else {
  100.     PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
  101.     my_exit(1);
  102.         return Nullch;
  103.     }
  104.     /*NOTREACHED*/
  105. }
  106.  
  107. /* paranoid version of realloc */
  108.  
  109. Malloc_t
  110. saferealloc(Malloc_t where,MEM_SIZE size)
  111. {
  112.     Malloc_t ptr;
  113. #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
  114.     Malloc_t PerlMem_realloc();
  115. #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
  116.  
  117. #ifdef HAS_64K_LIMIT 
  118.     if (size > 0xffff) {
  119.     PerlIO_printf(PerlIO_stderr(),
  120.               "Reallocation too large: %lx\n", size) FLUSH;
  121.     my_exit(1);
  122.     }
  123. #endif /* HAS_64K_LIMIT */
  124.     if (!size) {
  125.     safefree(where);
  126.     return NULL;
  127.     }
  128.  
  129.     if (!where)
  130.     return safemalloc(size);
  131. #ifdef DEBUGGING
  132.     if ((long)size < 0)
  133.     croak("panic: realloc");
  134. #endif
  135.     ptr = PerlMem_realloc(where,size);
  136.  
  137. #if !(defined(I286) || defined(atarist))
  138.     DEBUG_m( {
  139.     PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++);
  140.     PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
  141.     } )
  142. #else
  143.     DEBUG_m( {
  144.     PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++);
  145.     PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
  146.     } )
  147. #endif
  148.  
  149.     if (ptr != Nullch)
  150.     return ptr;
  151.     else if (PL_nomemok)
  152.     return Nullch;
  153.     else {
  154.     PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
  155.     my_exit(1);
  156.     return Nullch;
  157.     }
  158.     /*NOTREACHED*/
  159. }
  160.  
  161. /* safe version of free */
  162.  
  163. Free_t
  164. safefree(Malloc_t where)
  165. {
  166. #if !(defined(I286) || defined(atarist))
  167.     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++));
  168. #else
  169.     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++));
  170. #endif
  171.     if (where) {
  172.     /*SUPPRESS 701*/
  173.     PerlMem_free(where);
  174.     }
  175. }
  176.  
  177. /* safe version of calloc */
  178.  
  179. Malloc_t
  180. safecalloc(MEM_SIZE count, MEM_SIZE size)
  181. {
  182.     Malloc_t ptr;
  183.  
  184. #ifdef HAS_64K_LIMIT
  185.     if (size * count > 0xffff) {
  186.     PerlIO_printf(PerlIO_stderr(),
  187.               "Allocation too large: %lx\n", size * count) FLUSH;
  188.     my_exit(1);
  189.     }
  190. #endif /* HAS_64K_LIMIT */
  191. #ifdef DEBUGGING
  192.     if ((long)size < 0 || (long)count < 0)
  193.     croak("panic: calloc");
  194. #endif
  195.     size *= count;
  196.     ptr = PerlMem_malloc(size?size:1);    /* malloc(0) is NASTY on our system */
  197. #if !(defined(I286) || defined(atarist))
  198.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld  x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
  199. #else
  200.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
  201. #endif
  202.     if (ptr != Nullch) {
  203.     memset((void*)ptr, 0, size);
  204.     return ptr;
  205.     }
  206.     else if (PL_nomemok)
  207.     return Nullch;
  208.     else {
  209.     PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
  210.     my_exit(1);
  211.     return Nullch;
  212.     }
  213.     /*NOTREACHED*/
  214. }
  215.  
  216. #endif /* !MYMALLOC */
  217.  
  218. #ifdef LEAKTEST
  219.  
  220. struct mem_test_strut {
  221.     union {
  222.     long type;
  223.     char c[2];
  224.     } u;
  225.     long size;
  226. };
  227.  
  228. #    define ALIGN sizeof(struct mem_test_strut)
  229.  
  230. #    define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
  231. #    define typeof_chunk(ch) \
  232.     (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
  233. #    define set_typeof_chunk(ch,t) \
  234.     (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
  235. #define SIZE_TO_Y(size) ( (size) > MAXY_SIZE                \
  236.               ? MAXYCOUNT - 1                 \
  237.               : ( (size) > 40                 \
  238.                   ? ((size) - 1)/8 + 5            \
  239.                   : ((size) - 1)/4))
  240.  
  241. Malloc_t
  242. safexmalloc(I32 x, MEM_SIZE size)
  243. {
  244.     register char* where = (char*)safemalloc(size + ALIGN);
  245.  
  246.     xcount[x] += size;
  247.     xycount[x][SIZE_TO_Y(size)]++;
  248.     set_typeof_chunk(where, x);
  249.     sizeof_chunk(where) = size;
  250.     return (Malloc_t)(where + ALIGN);
  251. }
  252.  
  253. Malloc_t
  254. safexrealloc(Malloc_t wh, MEM_SIZE size)
  255. {
  256.     char *where = (char*)wh;
  257.  
  258.     if (!wh)
  259.     return safexmalloc(0,size);
  260.     
  261.     {
  262.     MEM_SIZE old = sizeof_chunk(where - ALIGN);
  263.     int t = typeof_chunk(where - ALIGN);
  264.     register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
  265.     
  266.     xycount[t][SIZE_TO_Y(old)]--;
  267.     xycount[t][SIZE_TO_Y(size)]++;
  268.     xcount[t] += size - old;
  269.     sizeof_chunk(new) = size;
  270.     return (Malloc_t)(new + ALIGN);
  271.     }
  272. }
  273.  
  274. void
  275. safexfree(Malloc_t wh)
  276. {
  277.     I32 x;
  278.     char *where = (char*)wh;
  279.     MEM_SIZE size;
  280.     
  281.     if (!where)
  282.     return;
  283.     where -= ALIGN;
  284.     size = sizeof_chunk(where);
  285.     x = where[0] + 100 * where[1];
  286.     xcount[x] -= size;
  287.     xycount[x][SIZE_TO_Y(size)]--;
  288.     safefree(where);
  289. }
  290.  
  291. Malloc_t
  292. safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
  293. {
  294.     register char * where = (char*)safexmalloc(x, size * count + ALIGN);
  295.     xcount[x] += size;
  296.     xycount[x][SIZE_TO_Y(size)]++;
  297.     memset((void*)(where + ALIGN), 0, size * count);
  298.     set_typeof_chunk(where, x);
  299.     sizeof_chunk(where) = size;
  300.     return (Malloc_t)(where + ALIGN);
  301. }
  302.  
  303. static void
  304. xstat(int flag)
  305. {
  306.     register I32 i, j, total = 0;
  307.     I32 subtot[MAXYCOUNT];
  308.  
  309.     for (j = 0; j < MAXYCOUNT; j++) {
  310.     subtot[j] = 0;
  311.     }
  312.     
  313.     PerlIO_printf(PerlIO_stderr(), "   Id  subtot   4   8  12  16  20  24  28  32  36  40  48  56  64  72  80 80+\n", total);
  314.     for (i = 0; i < MAXXCOUNT; i++) {
  315.     total += xcount[i];
  316.     for (j = 0; j < MAXYCOUNT; j++) {
  317.         subtot[j] += xycount[i][j];
  318.     }
  319.     if (flag == 0
  320.         ? xcount[i]            /* Have something */
  321.         : (flag == 2 
  322.            ? xcount[i] != lastxcount[i] /* Changed */
  323.            : xcount[i] > lastxcount[i])) { /* Growed */
  324.         PerlIO_printf(PerlIO_stderr(),"%2d %02d %7ld ", i / 100, i % 100, 
  325.               flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
  326.         lastxcount[i] = xcount[i];
  327.         for (j = 0; j < MAXYCOUNT; j++) {
  328.         if ( flag == 0 
  329.              ? xycount[i][j]    /* Have something */
  330.              : (flag == 2 
  331.             ? xycount[i][j] != lastxycount[i][j] /* Changed */
  332.             : xycount[i][j] > lastxycount[i][j])) {    /* Growed */
  333.             PerlIO_printf(PerlIO_stderr(),"%3ld ", 
  334.                   flag == 2 
  335.                   ? xycount[i][j] - lastxycount[i][j] 
  336.                   : xycount[i][j]);
  337.             lastxycount[i][j] = xycount[i][j];
  338.         } else {
  339.             PerlIO_printf(PerlIO_stderr(), "  . ", xycount[i][j]);
  340.         }
  341.         }
  342.         PerlIO_printf(PerlIO_stderr(), "\n");
  343.     }
  344.     }
  345.     if (flag != 2) {
  346.     PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total);
  347.     for (j = 0; j < MAXYCOUNT; j++) {
  348.         if (subtot[j]) {
  349.         PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]);
  350.         } else {
  351.         PerlIO_printf(PerlIO_stderr(), "  . ");
  352.         }
  353.     }
  354.     PerlIO_printf(PerlIO_stderr(), "\n");    
  355.     }
  356. }
  357.  
  358. #endif /* LEAKTEST */
  359.  
  360. /* copy a string up to some (non-backslashed) delimiter, if any */
  361.  
  362. char *
  363. delimcpy(register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
  364. {
  365.     register I32 tolen;
  366.     for (tolen = 0; from < fromend; from++, tolen++) {
  367.     if (*from == '\\') {
  368.         if (from[1] == delim)
  369.         from++;
  370.         else {
  371.         if (to < toend)
  372.             *to++ = *from;
  373.         tolen++;
  374.         from++;
  375.         }
  376.     }
  377.     else if (*from == delim)
  378.         break;
  379.     if (to < toend)
  380.         *to++ = *from;
  381.     }
  382.     if (to < toend)
  383.     *to = '\0';
  384.     *retlen = tolen;
  385.     return from;
  386. }
  387.  
  388. /* return ptr to little string in big string, NULL if not found */
  389. /* This routine was donated by Corey Satten. */
  390.  
  391. char *
  392. instr(register char *big, register char *little)
  393. {
  394.     register char *s, *x;
  395.     register I32 first;
  396.  
  397.     if (!little)
  398.     return big;
  399.     first = *little++;
  400.     if (!first)
  401.     return big;
  402.     while (*big) {
  403.     if (*big++ != first)
  404.         continue;
  405.     for (x=big,s=little; *s; /**/ ) {
  406.         if (!*x)
  407.         return Nullch;
  408.         if (*s++ != *x++) {
  409.         s--;
  410.         break;
  411.         }
  412.     }
  413.     if (!*s)
  414.         return big-1;
  415.     }
  416.     return Nullch;
  417. }
  418.  
  419. /* same as instr but allow embedded nulls */
  420.  
  421. char *
  422. ninstr(register char *big, register char *bigend, char *little, char *lend)
  423. {
  424.     register char *s, *x;
  425.     register I32 first = *little;
  426.     register char *littleend = lend;
  427.  
  428.     if (!first && little >= littleend)
  429.     return big;
  430.     if (bigend - big < littleend - little)
  431.     return Nullch;
  432.     bigend -= littleend - little++;
  433.     while (big <= bigend) {
  434.     if (*big++ != first)
  435.         continue;
  436.     for (x=big,s=little; s < littleend; /**/ ) {
  437.         if (*s++ != *x++) {
  438.         s--;
  439.         break;
  440.         }
  441.     }
  442.     if (s >= littleend)
  443.         return big-1;
  444.     }
  445.     return Nullch;
  446. }
  447.  
  448. /* reverse of the above--find last substring */
  449.  
  450. char *
  451. rninstr(register char *big, char *bigend, char *little, char *lend)
  452. {
  453.     register char *bigbeg;
  454.     register char *s, *x;
  455.     register I32 first = *little;
  456.     register char *littleend = lend;
  457.  
  458.     if (!first && little >= littleend)
  459.     return bigend;
  460.     bigbeg = big;
  461.     big = bigend - (littleend - little++);
  462.     while (big >= bigbeg) {
  463.     if (*big-- != first)
  464.         continue;
  465.     for (x=big+2,s=little; s < littleend; /**/ ) {
  466.         if (*s++ != *x++) {
  467.         s--;
  468.         break;
  469.         }
  470.     }
  471.     if (s >= littleend)
  472.         return big+1;
  473.     }
  474.     return Nullch;
  475. }
  476.  
  477. /*
  478.  * Set up for a new ctype locale.
  479.  */
  480. void
  481. perl_new_ctype(char *newctype)
  482. {
  483. #ifdef USE_LOCALE_CTYPE
  484.  
  485.     int i;
  486.  
  487.     for (i = 0; i < 256; i++) {
  488.     if (isUPPER_LC(i))
  489.         fold_locale[i] = toLOWER_LC(i);
  490.     else if (isLOWER_LC(i))
  491.         fold_locale[i] = toUPPER_LC(i);
  492.     else
  493.         fold_locale[i] = i;
  494.     }
  495.  
  496. #endif /* USE_LOCALE_CTYPE */
  497. }
  498.  
  499. /*
  500.  * Set up for a new collation locale.
  501.  */
  502. void
  503. perl_new_collate(char *newcoll)
  504. {
  505. #ifdef USE_LOCALE_COLLATE
  506.  
  507.     if (! newcoll) {
  508.     if (PL_collation_name) {
  509.         ++PL_collation_ix;
  510.         Safefree(PL_collation_name);
  511.         PL_collation_name = NULL;
  512.         PL_collation_standard = TRUE;
  513.         PL_collxfrm_base = 0;
  514.         PL_collxfrm_mult = 2;
  515.     }
  516.     return;
  517.     }
  518.  
  519.     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
  520.     ++PL_collation_ix;
  521.     Safefree(PL_collation_name);
  522.     PL_collation_name = savepv(newcoll);
  523.     PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
  524.  
  525.     {
  526.       /*  2: at most so many chars ('a', 'b'). */
  527.       /* 50: surely no system expands a char more. */
  528. #define XFRMBUFSIZE  (2 * 50)
  529.       char xbuf[XFRMBUFSIZE];
  530.       Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
  531.       Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
  532.       SSize_t mult = fb - fa;
  533.       if (mult < 1)
  534.           croak("strxfrm() gets absurd");
  535.       PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
  536.       PL_collxfrm_mult = mult;
  537.     }
  538.     }
  539.  
  540. #endif /* USE_LOCALE_COLLATE */
  541. }
  542.  
  543. /*
  544.  * Set up for a new numeric locale.
  545.  */
  546. void
  547. perl_new_numeric(char *newnum)
  548. {
  549. #ifdef USE_LOCALE_NUMERIC
  550.  
  551.     if (! newnum) {
  552.     if (PL_numeric_name) {
  553.         Safefree(PL_numeric_name);
  554.         PL_numeric_name = NULL;
  555.         PL_numeric_standard = TRUE;
  556.         PL_numeric_local = TRUE;
  557.     }
  558.     return;
  559.     }
  560.  
  561.     if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
  562.     Safefree(PL_numeric_name);
  563.     PL_numeric_name = savepv(newnum);
  564.     PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
  565.     PL_numeric_local = TRUE;
  566.     }
  567.  
  568. #endif /* USE_LOCALE_NUMERIC */
  569. }
  570.  
  571. void
  572. perl_set_numeric_standard(void)
  573. {
  574. #ifdef USE_LOCALE_NUMERIC
  575.  
  576.     if (! PL_numeric_standard) {
  577.     setlocale(LC_NUMERIC, "C");
  578.     PL_numeric_standard = TRUE;
  579.     PL_numeric_local = FALSE;
  580.     }
  581.  
  582. #endif /* USE_LOCALE_NUMERIC */
  583. }
  584.  
  585. void
  586. perl_set_numeric_local(void)
  587. {
  588. #ifdef USE_LOCALE_NUMERIC
  589.  
  590.     if (! PL_numeric_local) {
  591.     setlocale(LC_NUMERIC, PL_numeric_name);
  592.     PL_numeric_standard = FALSE;
  593.     PL_numeric_local = TRUE;
  594.     }
  595.  
  596. #endif /* USE_LOCALE_NUMERIC */
  597. }
  598.  
  599.  
  600. /*
  601.  * Initialize locale awareness.
  602.  */
  603. int
  604. perl_init_i18nl10n(int printwarn)
  605. {
  606.     int ok = 1;
  607.     /* returns
  608.      *    1 = set ok or not applicable,
  609.      *    0 = fallback to C locale,
  610.      *   -1 = fallback to C locale failed
  611.      */
  612.  
  613. #ifdef USE_LOCALE
  614.  
  615. #ifdef USE_LOCALE_CTYPE
  616.     char *curctype   = NULL;
  617. #endif /* USE_LOCALE_CTYPE */
  618. #ifdef USE_LOCALE_COLLATE
  619.     char *curcoll    = NULL;
  620. #endif /* USE_LOCALE_COLLATE */
  621. #ifdef USE_LOCALE_NUMERIC
  622.     char *curnum     = NULL;
  623. #endif /* USE_LOCALE_NUMERIC */
  624.     char *lc_all     = PerlEnv_getenv("LC_ALL");
  625.     char *lang       = PerlEnv_getenv("LANG");
  626.     bool setlocale_failure = FALSE;
  627.  
  628. #ifdef LOCALE_ENVIRON_REQUIRED
  629.  
  630.     /*
  631.      * Ultrix setlocale(..., "") fails if there are no environment
  632.      * variables from which to get a locale name.
  633.      */
  634.  
  635.     bool done = FALSE;
  636.  
  637. #ifdef LC_ALL
  638.     if (lang) {
  639.     if (setlocale(LC_ALL, ""))
  640.         done = TRUE;
  641.     else
  642.         setlocale_failure = TRUE;
  643.     }
  644.     if (!setlocale_failure)
  645. #endif /* LC_ALL */
  646.     {
  647. #ifdef USE_LOCALE_CTYPE
  648.     if (! (curctype = setlocale(LC_CTYPE,
  649.                     (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
  650.                     ? "" : Nullch)))
  651.         setlocale_failure = TRUE;
  652. #endif /* USE_LOCALE_CTYPE */
  653. #ifdef USE_LOCALE_COLLATE
  654.     if (! (curcoll = setlocale(LC_COLLATE,
  655.                    (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
  656.                    ? "" : Nullch)))
  657.         setlocale_failure = TRUE;
  658. #endif /* USE_LOCALE_COLLATE */
  659. #ifdef USE_LOCALE_NUMERIC
  660.     if (! (curnum = setlocale(LC_NUMERIC,
  661.                   (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
  662.                   ? "" : Nullch)))
  663.         setlocale_failure = TRUE;
  664. #endif /* USE_LOCALE_NUMERIC */
  665.     }
  666.  
  667. #else /* !LOCALE_ENVIRON_REQUIRED */
  668.  
  669. #ifdef LC_ALL
  670.  
  671.     if (! setlocale(LC_ALL, ""))
  672.     setlocale_failure = TRUE;
  673.     else {
  674. #ifdef USE_LOCALE_CTYPE
  675.     curctype = setlocale(LC_CTYPE, Nullch);
  676. #endif /* USE_LOCALE_CTYPE */
  677. #ifdef USE_LOCALE_COLLATE
  678.     curcoll = setlocale(LC_COLLATE, Nullch);
  679. #endif /* USE_LOCALE_COLLATE */
  680. #ifdef USE_LOCALE_NUMERIC
  681.     curnum = setlocale(LC_NUMERIC, Nullch);
  682. #endif /* USE_LOCALE_NUMERIC */
  683.     }
  684.  
  685. #else /* !LC_ALL */
  686.  
  687. #ifdef USE_LOCALE_CTYPE
  688.     if (! (curctype = setlocale(LC_CTYPE, "")))
  689.     setlocale_failure = TRUE;
  690. #endif /* USE_LOCALE_CTYPE */
  691. #ifdef USE_LOCALE_COLLATE
  692.     if (! (curcoll = setlocale(LC_COLLATE, "")))
  693.     setlocale_failure = TRUE;
  694. #endif /* USE_LOCALE_COLLATE */
  695. #ifdef USE_LOCALE_NUMERIC
  696.     if (! (curnum = setlocale(LC_NUMERIC, "")))
  697.     setlocale_failure = TRUE;
  698. #endif /* USE_LOCALE_NUMERIC */
  699.  
  700. #endif /* LC_ALL */
  701.  
  702. #endif /* !LOCALE_ENVIRON_REQUIRED */
  703.  
  704.     if (setlocale_failure) {
  705.     char *p;
  706.     bool locwarn = (printwarn > 1 || 
  707.             printwarn &&
  708.             (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
  709.  
  710.     if (locwarn) {
  711. #ifdef LC_ALL
  712.   
  713.         PerlIO_printf(PerlIO_stderr(),
  714.            "perl: warning: Setting locale failed.\n");
  715.  
  716. #else /* !LC_ALL */
  717.   
  718.         PerlIO_printf(PerlIO_stderr(),
  719.            "perl: warning: Setting locale failed for the categories:\n\t");
  720. #ifdef USE_LOCALE_CTYPE
  721.         if (! curctype)
  722.         PerlIO_printf(PerlIO_stderr(), "LC_CTYPE ");
  723. #endif /* USE_LOCALE_CTYPE */
  724. #ifdef USE_LOCALE_COLLATE
  725.         if (! curcoll)
  726.         PerlIO_printf(PerlIO_stderr(), "LC_COLLATE ");
  727. #endif /* USE_LOCALE_COLLATE */
  728. #ifdef USE_LOCALE_NUMERIC
  729.         if (! curnum)
  730.         PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC ");
  731. #endif /* USE_LOCALE_NUMERIC */
  732.         PerlIO_printf(PerlIO_stderr(), "\n");
  733.  
  734. #endif /* LC_ALL */
  735.  
  736.         PerlIO_printf(PerlIO_stderr(),
  737.         "perl: warning: Please check that your locale settings:\n");
  738.  
  739.         PerlIO_printf(PerlIO_stderr(),
  740.               "\tLC_ALL = %c%s%c,\n",
  741.               lc_all ? '"' : '(',
  742.               lc_all ? lc_all : "unset",
  743.               lc_all ? '"' : ')');
  744.  
  745.         {
  746.           char **e;
  747.           for (e = environ; *e; e++) {
  748.           if (strnEQ(*e, "LC_", 3)
  749.             && strnNE(*e, "LC_ALL=", 7)
  750.             && (p = strchr(*e, '=')))
  751.               PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n",
  752.                     (int)(p - *e), *e, p + 1);
  753.           }
  754.         }
  755.  
  756.         PerlIO_printf(PerlIO_stderr(),
  757.               "\tLANG = %c%s%c\n",
  758.               lang ? '"' : '(',
  759.               lang ? lang : "unset",
  760.               lang ? '"' : ')');
  761.  
  762.         PerlIO_printf(PerlIO_stderr(),
  763.               "    are supported and installed on your system.\n");
  764.     }
  765.  
  766. #ifdef LC_ALL
  767.  
  768.     if (setlocale(LC_ALL, "C")) {
  769.         if (locwarn)
  770.         PerlIO_printf(PerlIO_stderr(),
  771.       "perl: warning: Falling back to the standard locale (\"C\").\n");
  772.         ok = 0;
  773.     }
  774.     else {
  775.         if (locwarn)
  776.         PerlIO_printf(PerlIO_stderr(),
  777.       "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
  778.         ok = -1;
  779.     }
  780.  
  781. #else /* ! LC_ALL */
  782.  
  783.     if (0
  784. #ifdef USE_LOCALE_CTYPE
  785.         || !(curctype || setlocale(LC_CTYPE, "C"))
  786. #endif /* USE_LOCALE_CTYPE */
  787. #ifdef USE_LOCALE_COLLATE
  788.         || !(curcoll || setlocale(LC_COLLATE, "C"))
  789. #endif /* USE_LOCALE_COLLATE */
  790. #ifdef USE_LOCALE_NUMERIC
  791.         || !(curnum || setlocale(LC_NUMERIC, "C"))
  792. #endif /* USE_LOCALE_NUMERIC */
  793.         )
  794.     {
  795.         if (locwarn)
  796.         PerlIO_printf(PerlIO_stderr(),
  797.       "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
  798.         ok = -1;
  799.     }
  800.  
  801. #endif /* ! LC_ALL */
  802.  
  803. #ifdef USE_LOCALE_CTYPE
  804.     curctype = setlocale(LC_CTYPE, Nullch);
  805. #endif /* USE_LOCALE_CTYPE */
  806. #ifdef USE_LOCALE_COLLATE
  807.     curcoll = setlocale(LC_COLLATE, Nullch);
  808. #endif /* USE_LOCALE_COLLATE */
  809. #ifdef USE_LOCALE_NUMERIC
  810.     curnum = setlocale(LC_NUMERIC, Nullch);
  811. #endif /* USE_LOCALE_NUMERIC */
  812.     }
  813.  
  814. #ifdef USE_LOCALE_CTYPE
  815.     perl_new_ctype(curctype);
  816. #endif /* USE_LOCALE_CTYPE */
  817.  
  818. #ifdef USE_LOCALE_COLLATE
  819.     perl_new_collate(curcoll);
  820. #endif /* USE_LOCALE_COLLATE */
  821.  
  822. #ifdef USE_LOCALE_NUMERIC
  823.     perl_new_numeric(curnum);
  824. #endif /* USE_LOCALE_NUMERIC */
  825.  
  826. #endif /* USE_LOCALE */
  827.  
  828.     return ok;
  829. }
  830.  
  831. /* Backwards compatibility. */
  832. int
  833. perl_init_i18nl14n(int printwarn)
  834. {
  835.     return perl_init_i18nl10n(printwarn);
  836. }
  837.  
  838. #ifdef USE_LOCALE_COLLATE
  839.  
  840. /*
  841.  * mem_collxfrm() is a bit like strxfrm() but with two important
  842.  * differences. First, it handles embedded NULs. Second, it allocates
  843.  * a bit more memory than needed for the transformed data itself.
  844.  * The real transformed data begins at offset sizeof(collationix).
  845.  * Please see sv_collxfrm() to see how this is used.
  846.  */
  847. char *
  848. mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen)
  849. {
  850.     char *xbuf;
  851.     STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
  852.  
  853.     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
  854.     /* the +1 is for the terminating NUL. */
  855.  
  856.     xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
  857.     New(171, xbuf, xAlloc, char);
  858.     if (! xbuf)
  859.     goto bad;
  860.  
  861.     *(U32*)xbuf = PL_collation_ix;
  862.     xout = sizeof(PL_collation_ix);
  863.     for (xin = 0; xin < len; ) {
  864.     SSize_t xused;
  865.  
  866.     for (;;) {
  867.         xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
  868.         if (xused == -1)
  869.         goto bad;
  870.         if (xused < xAlloc - xout)
  871.         break;
  872.         xAlloc = (2 * xAlloc) + 1;
  873.         Renew(xbuf, xAlloc, char);
  874.         if (! xbuf)
  875.         goto bad;
  876.     }
  877.  
  878.     xin += strlen(s + xin) + 1;
  879.     xout += xused;
  880.  
  881.     /* Embedded NULs are understood but silently skipped
  882.      * because they make no sense in locale collation. */
  883.     }
  884.  
  885.     xbuf[xout] = '\0';
  886.     *xlen = xout - sizeof(PL_collation_ix);
  887.     return xbuf;
  888.  
  889.   bad:
  890.     Safefree(xbuf);
  891.     *xlen = 0;
  892.     return NULL;
  893. }
  894.  
  895. #endif /* USE_LOCALE_COLLATE */
  896.  
  897. void
  898. fbm_compile(SV *sv, U32 flags /* not used yet */)
  899. {
  900.     register unsigned char *s;
  901.     register unsigned char *table;
  902.     register U32 i;
  903.     register U32 len = SvCUR(sv);
  904.     I32 rarest = 0;
  905.     U32 frequency = 256;
  906.  
  907.     sv_upgrade(sv, SVt_PVBM);
  908.     if (len > 255 || len == 0)    /* TAIL might be on on a zero-length string. */
  909.     return;            /* can't have offsets that big */
  910.     if (len > 2) {
  911.     Sv_Grow(sv,len + 258);
  912.     table = (unsigned char*)(SvPVX(sv) + len + 1);
  913.     s = table - 2;
  914.     for (i = 0; i < 256; i++) {
  915.         table[i] = len;
  916.     }
  917.     i = 0;
  918.     while (s >= (unsigned char*)(SvPVX(sv)))
  919.         {
  920.         if (table[*s] == len)
  921.             table[*s] = i;
  922.         s--,i++;
  923.         }
  924.     }
  925.     sv_magic(sv, Nullsv, 'B', Nullch, 0);    /* deep magic */
  926.     SvVALID_on(sv);
  927.  
  928.     s = (unsigned char*)(SvPVX(sv));        /* deeper magic */
  929.     for (i = 0; i < len; i++) {
  930.     if (freq[s[i]] < frequency) {
  931.         rarest = i;
  932.         frequency = freq[s[i]];
  933.     }
  934.     }
  935.     BmRARE(sv) = s[rarest];
  936.     BmPREVIOUS(sv) = rarest;
  937.     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
  938. }
  939.  
  940. char *
  941. fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
  942. {
  943.     register unsigned char *s;
  944.     register I32 tmp;
  945.     register I32 littlelen;
  946.     register unsigned char *little;
  947.     register unsigned char *table;
  948.     register unsigned char *olds;
  949.     register unsigned char *oldlittle;
  950.  
  951.     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
  952.     STRLEN len;
  953.     char *l = SvPV(littlestr,len);
  954.     if (!len) {
  955.         if (SvTAIL(littlestr)) {    /* Can be only 0-len constant
  956.                        substr => we can ignore SvVALID */
  957.         if (PL_multiline) {
  958.             char *t = "\n";
  959.             if ((s = (unsigned char*)ninstr((char*)big, (char*)bigend,
  960.                              t, t + len))) {
  961.             return (char*)s;
  962.             }
  963.         }
  964.         if (bigend > big && bigend[-1] == '\n')
  965.             return (char *)(bigend - 1);
  966.         else
  967.             return (char *) bigend;
  968.         }
  969.         return (char*)big;
  970.     }
  971.     return ninstr((char*)big,(char*)bigend, l, l + len);
  972.     }
  973.  
  974.     littlelen = SvCUR(littlestr);
  975.     if (SvTAIL(littlestr) && !PL_multiline) {    /* tail anchored? */
  976.     if (littlelen > bigend - big)
  977.         return Nullch;
  978.     little = (unsigned char*)SvPVX(littlestr);
  979.     s = bigend - littlelen;
  980.     if (s > big
  981.         && bigend[-1] == '\n' 
  982.         && s[-1] == *little && memEQ((char*)s - 1,(char*)little,littlelen))
  983.         return (char*)s - 1;    /* how sweet it is */
  984.     else if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
  985.         return (char*)s;        /* how sweet it is */
  986.     return Nullch;
  987.     }
  988.     if (littlelen <= 2) {
  989.     unsigned char c1 = (unsigned char)SvPVX(littlestr)[0];
  990.     unsigned char c2 = (unsigned char)SvPVX(littlestr)[1];
  991.     /* This may do extra comparisons if littlelen == 2, but this
  992.        should be hidden in the noise since we do less indirection. */
  993.     
  994.     s = big;
  995.     bigend -= littlelen;
  996.     while (s <= bigend) {
  997.         if (s[0] == c1 
  998.         && (littlelen == 1 || s[1] == c2)
  999.         && (!SvTAIL(littlestr)
  1000.             || s == bigend
  1001.             || s[littlelen] == '\n')) /* Automatically multiline */
  1002.         {
  1003.         return (char*)s;
  1004.         }
  1005.         s++;
  1006.     }
  1007.     return Nullch;
  1008.     }
  1009.     table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
  1010.     if (--littlelen >= bigend - big)
  1011.     return Nullch;
  1012.     s = big + littlelen;
  1013.     oldlittle = little = table - 2;
  1014.     if (s < bigend) {
  1015.       top2:
  1016.     /*SUPPRESS 560*/
  1017.     if (tmp = table[*s]) {
  1018. #ifdef POINTERRIGOR
  1019.         if (bigend - s > tmp) {
  1020.         s += tmp;
  1021.         goto top2;
  1022.         }
  1023. #else
  1024.         if ((s += tmp) < bigend)
  1025.         goto top2;
  1026. #endif
  1027.         return Nullch;
  1028.     }
  1029.     else {
  1030.         tmp = littlelen;    /* less expensive than calling strncmp() */
  1031.         olds = s;
  1032.         while (tmp--) {
  1033.         if (*--s == *--little)
  1034.             continue;
  1035.           differ:
  1036.         s = olds + 1;    /* here we pay the price for failure */
  1037.         little = oldlittle;
  1038.         if (s < bigend)    /* fake up continue to outer loop */
  1039.             goto top2;
  1040.         return Nullch;
  1041.         }
  1042.         if (SvTAIL(littlestr)    /* automatically multiline */
  1043.         && olds + 1 != bigend
  1044.         && olds[1] != '\n') 
  1045.         goto differ;
  1046.         return (char *)s;
  1047.     }
  1048.     }
  1049.     return Nullch;
  1050. }
  1051.  
  1052. /* start_shift, end_shift are positive quantities which give offsets
  1053.    of ends of some substring of bigstr.
  1054.    If `last' we want the last occurence.
  1055.    old_posp is the way of communication between consequent calls if
  1056.    the next call needs to find the . 
  1057.    The initial *old_posp should be -1.
  1058.    Note that we do not take into account SvTAIL, so it may give wrong
  1059.    positives if _ALL flag is set.
  1060.  */
  1061.  
  1062. char *
  1063. screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
  1064. {
  1065.     dTHR;
  1066.     register unsigned char *s, *x;
  1067.     register unsigned char *big;
  1068.     register I32 pos;
  1069.     register I32 previous;
  1070.     register I32 first;
  1071.     register unsigned char *little;
  1072.     register I32 stop_pos;
  1073.     register unsigned char *littleend;
  1074.     I32 found = 0;
  1075.  
  1076.     if (*old_posp == -1
  1077.     ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
  1078.     : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0))
  1079.     return Nullch;
  1080.     little = (unsigned char *)(SvPVX(littlestr));
  1081.     littleend = little + SvCUR(littlestr);
  1082.     first = *little++;
  1083.     /* The value of pos we can start at: */
  1084.     previous = BmPREVIOUS(littlestr);
  1085.     big = (unsigned char *)(SvPVX(bigstr));
  1086.     /* The value of pos we can stop at: */
  1087.     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
  1088.     if (previous + start_shift > stop_pos) return Nullch;
  1089.     while (pos < previous + start_shift) {
  1090.     if (!(pos += PL_screamnext[pos]))
  1091.         return Nullch;
  1092.     }
  1093. #ifdef POINTERRIGOR
  1094.     do {
  1095.     if (pos >= stop_pos) break;
  1096.     if (big[pos-previous] != first)
  1097.         continue;
  1098.     for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
  1099.         if (*s++ != *x++) {
  1100.         s--;
  1101.         break;
  1102.         }
  1103.     }
  1104.     if (s == littleend) {
  1105.         *old_posp = pos;
  1106.         if (!last) return (char *)(big+pos-previous);
  1107.         found = 1;
  1108.     }
  1109.     } while ( pos += PL_screamnext[pos] );
  1110.     return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
  1111. #else /* !POINTERRIGOR */
  1112.     big -= previous;
  1113.     do {
  1114.     if (pos >= stop_pos) break;
  1115.     if (big[pos] != first)
  1116.         continue;
  1117.     for (x=big+pos+1,s=little; s < littleend; /**/ ) {
  1118.         if (*s++ != *x++) {
  1119.         s--;
  1120.         break;
  1121.         }
  1122.     }
  1123.     if (s == littleend) {
  1124.         *old_posp = pos;
  1125.         if (!last) return (char *)(big+pos);
  1126.         found = 1;
  1127.     }
  1128.     } while ( pos += PL_screamnext[pos] );
  1129.     return (last && found) ? (char *)(big+(*old_posp)) : Nullch;
  1130. #endif /* POINTERRIGOR */
  1131. }
  1132.  
  1133. I32
  1134. ibcmp(char *s1, char *s2, register I32 len)
  1135. {
  1136.     register U8 *a = (U8 *)s1;
  1137.     register U8 *b = (U8 *)s2;
  1138.     while (len--) {
  1139.     if (*a != *b && *a != fold[*b])
  1140.         return 1;
  1141.     a++,b++;
  1142.     }
  1143.     return 0;
  1144. }
  1145.  
  1146. I32
  1147. ibcmp_locale(char *s1, char *s2, register I32 len)
  1148. {
  1149.     register U8 *a = (U8 *)s1;
  1150.     register U8 *b = (U8 *)s2;
  1151.     while (len--) {
  1152.     if (*a != *b && *a != fold_locale[*b])
  1153.         return 1;
  1154.     a++,b++;
  1155.     }
  1156.     return 0;
  1157. }
  1158.  
  1159. /* copy a string to a safe spot */
  1160.  
  1161. char *
  1162. savepv(char *sv)
  1163. {
  1164.     register char *newaddr;
  1165.  
  1166.     New(902,newaddr,strlen(sv)+1,char);
  1167.     (void)strcpy(newaddr,sv);
  1168.     return newaddr;
  1169. }
  1170.  
  1171. /* same thing but with a known length */
  1172.  
  1173. char *
  1174. savepvn(char *sv, register I32 len)
  1175. {
  1176.     register char *newaddr;
  1177.  
  1178.     New(903,newaddr,len+1,char);
  1179.     Copy(sv,newaddr,len,char);        /* might not be null terminated */
  1180.     newaddr[len] = '\0';        /* is now */
  1181.     return newaddr;
  1182. }
  1183.  
  1184. /* the SV for form() and mess() is not kept in an arena */
  1185.  
  1186. STATIC SV *
  1187. mess_alloc(void)
  1188. {
  1189.     SV *sv;
  1190.     XPVMG *any;
  1191.  
  1192.     /* Create as PVMG now, to avoid any upgrading later */
  1193.     New(905, sv, 1, SV);
  1194.     Newz(905, any, 1, XPVMG);
  1195.     SvFLAGS(sv) = SVt_PVMG;
  1196.     SvANY(sv) = (void*)any;
  1197.     SvREFCNT(sv) = 1 << 30; /* practically infinite */
  1198.     return sv;
  1199. }
  1200.  
  1201. char *
  1202. form(const char* pat, ...)
  1203. {
  1204.     va_list args;
  1205.     va_start(args, pat);
  1206.     if (!PL_mess_sv)
  1207.     PL_mess_sv = mess_alloc();
  1208.     sv_vsetpvfn(PL_mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
  1209.     va_end(args);
  1210.     return SvPVX(PL_mess_sv);
  1211. }
  1212.  
  1213. char *
  1214. mess(const char *pat, va_list *args)
  1215. {
  1216.     SV *sv;
  1217.     static char dgd[] = " during global destruction.\n";
  1218.  
  1219.     if (!PL_mess_sv)
  1220.     PL_mess_sv = mess_alloc();
  1221.     sv = PL_mess_sv;
  1222.     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
  1223.     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
  1224.     dTHR;
  1225.     if (PL_dirty)
  1226.         sv_catpv(sv, dgd);
  1227.     else {
  1228.         if (PL_curcop->cop_line)
  1229.         sv_catpvf(sv, " at %_ line %ld",
  1230.               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
  1231.         if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
  1232.         bool line_mode = (RsSIMPLE(PL_rs) &&
  1233.                   SvLEN(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
  1234.         sv_catpvf(sv, ", <%s> %s %ld",
  1235.               PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
  1236.               line_mode ? "line" : "chunk", 
  1237.               (long)IoLINES(GvIOp(PL_last_in_gv)));
  1238.         }
  1239.         sv_catpv(sv, ".\n");
  1240.     }
  1241.     }
  1242.     return SvPVX(sv);
  1243. }
  1244.  
  1245. OP *
  1246. die(const char* pat, ...)
  1247. {
  1248.     dTHR;
  1249.     va_list args;
  1250.     char *message;
  1251.     int was_in_eval = PL_in_eval;
  1252.     HV *stash;
  1253.     GV *gv;
  1254.     CV *cv;
  1255.  
  1256. #ifdef USE_THREADS
  1257.     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
  1258.               "%p: die: curstack = %p, mainstack = %p\n",
  1259.               thr, PL_curstack, PL_mainstack));
  1260. #endif /* USE_THREADS */
  1261.  
  1262.     va_start(args, pat);
  1263.     message = pat ? mess(pat, &args) : Nullch;
  1264.     va_end(args);
  1265.  
  1266. #ifdef USE_THREADS
  1267.     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
  1268.               "%p: die: message = %s\ndiehook = %p\n",
  1269.               thr, message, PL_diehook));
  1270. #endif /* USE_THREADS */
  1271.     if (PL_diehook) {
  1272.     /* sv_2cv might call croak() */
  1273.     SV *olddiehook = PL_diehook;
  1274.     ENTER;
  1275.     SAVESPTR(PL_diehook);
  1276.     PL_diehook = Nullsv;
  1277.     cv = sv_2cv(olddiehook, &stash, &gv, 0);
  1278.     LEAVE;
  1279.     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1280.         dSP;
  1281.         SV *msg;
  1282.  
  1283.         ENTER;
  1284.         if(message) {
  1285.         msg = newSVpv(message, 0);
  1286.         SvREADONLY_on(msg);
  1287.         SAVEFREESV(msg);
  1288.         }
  1289.         else {
  1290.         msg = ERRSV;
  1291.         }
  1292.  
  1293.         PUSHSTACKi(PERLSI_DIEHOOK);
  1294.         PUSHMARK(SP);
  1295.         XPUSHs(msg);
  1296.         PUTBACK;
  1297.         perl_call_sv((SV*)cv, G_DISCARD);
  1298.         POPSTACK;
  1299.         LEAVE;
  1300.     }
  1301.     }
  1302.  
  1303.     PL_restartop = die_where(message);
  1304. #ifdef USE_THREADS
  1305.     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
  1306.       "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
  1307.       thr, PL_restartop, was_in_eval, PL_top_env));
  1308. #endif /* USE_THREADS */
  1309.     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
  1310.     JMPENV_JUMP(3);
  1311.     return PL_restartop;
  1312. }
  1313.  
  1314. void
  1315. croak(const char* pat, ...)
  1316. {
  1317.     dTHR;
  1318.     va_list args;
  1319.     char *message;
  1320.     HV *stash;
  1321.     GV *gv;
  1322.     CV *cv;
  1323.  
  1324.     va_start(args, pat);
  1325.     message = mess(pat, &args);
  1326.     va_end(args);
  1327. #ifdef USE_THREADS
  1328.     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
  1329. #endif /* USE_THREADS */
  1330.     if (PL_diehook) {
  1331.     /* sv_2cv might call croak() */
  1332.     SV *olddiehook = PL_diehook;
  1333.     ENTER;
  1334.     SAVESPTR(PL_diehook);
  1335.     PL_diehook = Nullsv;
  1336.     cv = sv_2cv(olddiehook, &stash, &gv, 0);
  1337.     LEAVE;
  1338.     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1339.         dSP;
  1340.         SV *msg;
  1341.  
  1342.         ENTER;
  1343.         msg = newSVpv(message, 0);
  1344.         SvREADONLY_on(msg);
  1345.         SAVEFREESV(msg);
  1346.  
  1347.         PUSHSTACKi(PERLSI_DIEHOOK);
  1348.         PUSHMARK(SP);
  1349.         XPUSHs(msg);
  1350.         PUTBACK;
  1351.         perl_call_sv((SV*)cv, G_DISCARD);
  1352.         POPSTACK;
  1353.         LEAVE;
  1354.     }
  1355.     }
  1356.     if (PL_in_eval) {
  1357.     PL_restartop = die_where(message);
  1358.     JMPENV_JUMP(3);
  1359.     }
  1360.     PerlIO_puts(PerlIO_stderr(),message);
  1361.     (void)PerlIO_flush(PerlIO_stderr());
  1362.     my_failure_exit();
  1363. }
  1364.  
  1365. void
  1366. warn(const char* pat,...)
  1367. {
  1368.     va_list args;
  1369.     char *message;
  1370.     HV *stash;
  1371.     GV *gv;
  1372.     CV *cv;
  1373.  
  1374.     va_start(args, pat);
  1375.     message = mess(pat, &args);
  1376.     va_end(args);
  1377.  
  1378.     if (PL_warnhook) {
  1379.     /* sv_2cv might call warn() */
  1380.     dTHR;
  1381.     SV *oldwarnhook = PL_warnhook;
  1382.     ENTER;
  1383.     SAVESPTR(PL_warnhook);
  1384.     PL_warnhook = Nullsv;
  1385.     cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
  1386.     LEAVE;
  1387.     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1388.         dSP;
  1389.         SV *msg;
  1390.  
  1391.         ENTER;
  1392.         msg = newSVpv(message, 0);
  1393.         SvREADONLY_on(msg);
  1394.         SAVEFREESV(msg);
  1395.  
  1396.         PUSHSTACKi(PERLSI_WARNHOOK);
  1397.         PUSHMARK(SP);
  1398.         XPUSHs(msg);
  1399.         PUTBACK;
  1400.         perl_call_sv((SV*)cv, G_DISCARD);
  1401.         POPSTACK;
  1402.         LEAVE;
  1403.         return;
  1404.     }
  1405.     }
  1406.     PerlIO_puts(PerlIO_stderr(),message);
  1407. #ifdef LEAKTEST
  1408.     DEBUG_L(*message == '!' 
  1409.         ? (xstat(message[1]=='!'
  1410.              ? (message[2]=='!' ? 2 : 1)
  1411.              : 0)
  1412.            , 0)
  1413.         : 0);
  1414. #endif
  1415.     (void)PerlIO_flush(PerlIO_stderr());
  1416. }
  1417.  
  1418. #ifndef VMS  /* VMS' my_setenv() is in VMS.c */
  1419. #ifndef WIN32
  1420. void
  1421. my_setenv(char *nam, char *val)
  1422. {
  1423.     register I32 i=setenv_getix(nam);        /* where does it go? */
  1424.  
  1425.     if (environ == PL_origenviron) {    /* need we copy environment? */
  1426.     I32 j;
  1427.     I32 max;
  1428.     char **tmpenv;
  1429.  
  1430.     /*SUPPRESS 530*/
  1431.     for (max = i; environ[max]; max++) ;
  1432.     New(901,tmpenv, max+2, char*);
  1433.     for (j=0; j<max; j++)        /* copy environment */
  1434.         tmpenv[j] = savepv(environ[j]);
  1435.     tmpenv[max] = Nullch;
  1436.     environ = tmpenv;        /* tell exec where it is now */
  1437.     }
  1438.     if (!val) {
  1439.     Safefree(environ[i]);
  1440.     while (environ[i]) {
  1441.         environ[i] = environ[i+1];
  1442.         i++;
  1443.     }
  1444.     return;
  1445.     }
  1446.     if (!environ[i]) {            /* does not exist yet */
  1447.     Renew(environ, i+2, char*);    /* just expand it a bit */
  1448.     environ[i+1] = Nullch;    /* make sure it's null terminated */
  1449.     }
  1450.     else
  1451.     Safefree(environ[i]);
  1452.     New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
  1453. #ifndef MSDOS
  1454.     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
  1455. #else
  1456.     /* MS-DOS requires environment variable names to be in uppercase */
  1457.     /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
  1458.      * some utilities and applications may break because they only look
  1459.      * for upper case strings. (Fixed strupr() bug here.)]
  1460.      */
  1461.     strcpy(environ[i],nam); strupr(environ[i]);
  1462.     (void)sprintf(environ[i] + strlen(nam),"=%s",val);
  1463. #endif /* MSDOS */
  1464. }
  1465.  
  1466. #else /* if WIN32 */
  1467.  
  1468. void
  1469. my_setenv(char *nam,char *val)
  1470. {
  1471.  
  1472. #ifdef USE_WIN32_RTL_ENV
  1473.  
  1474.     register char *envstr;
  1475.     STRLEN namlen = strlen(nam);
  1476.     STRLEN vallen;
  1477.     char *oldstr = environ[setenv_getix(nam)];
  1478.  
  1479.     /* putenv() has totally broken semantics in both the Borland
  1480.      * and Microsoft CRTLs.  They either store the passed pointer in
  1481.      * the environment without making a copy, or make a copy and don't
  1482.      * free it. And on top of that, they dont free() old entries that
  1483.      * are being replaced/deleted.  This means the caller must
  1484.      * free any old entries somehow, or we end up with a memory
  1485.      * leak every time my_setenv() is called.  One might think
  1486.      * one could directly manipulate environ[], like the UNIX code
  1487.      * above, but direct changes to environ are not allowed when
  1488.      * calling putenv(), since the RTLs maintain an internal
  1489.      * *copy* of environ[]. Bad, bad, *bad* stink.
  1490.      * GSAR 97-06-07
  1491.      */
  1492.  
  1493.     if (!val) {
  1494.     if (!oldstr)
  1495.         return;
  1496.     val = "";
  1497.     vallen = 0;
  1498.     }
  1499.     else
  1500.     vallen = strlen(val);
  1501.     New(904, envstr, namlen + vallen + 3, char);
  1502.     (void)sprintf(envstr,"%s=%s",nam,val);
  1503.     (void)PerlEnv_putenv(envstr);
  1504.     if (oldstr)
  1505.     Safefree(oldstr);
  1506. #ifdef _MSC_VER
  1507.     Safefree(envstr);        /* MSVCRT leaks without this */
  1508. #endif
  1509.  
  1510. #else /* !USE_WIN32_RTL_ENV */
  1511.  
  1512.     /* The sane way to deal with the environment.
  1513.      * Has these advantages over putenv() & co.:
  1514.      *  * enables us to store a truly empty value in the
  1515.      *    environment (like in UNIX).
  1516.      *  * we don't have to deal with RTL globals, bugs and leaks.
  1517.      *  * Much faster.
  1518.      * Why you may want to enable USE_WIN32_RTL_ENV:
  1519.      *  * environ[] and RTL functions will not reflect changes,
  1520.      *    which might be an issue if extensions want to access
  1521.      *    the env. via RTL.  This cuts both ways, since RTL will
  1522.      *    not see changes made by extensions that call the Win32
  1523.      *    functions directly, either.
  1524.      * GSAR 97-06-07
  1525.      */
  1526.     SetEnvironmentVariable(nam,val);
  1527.  
  1528. #endif
  1529. }
  1530.  
  1531. #endif /* WIN32 */
  1532.  
  1533. I32
  1534. setenv_getix(char *nam)
  1535. {
  1536.     register I32 i, len = strlen(nam);
  1537.  
  1538.     for (i = 0; environ[i]; i++) {
  1539.     if (
  1540. #ifdef WIN32
  1541.         strnicmp(environ[i],nam,len) == 0
  1542. #else
  1543.         strnEQ(environ[i],nam,len)
  1544. #endif
  1545.         && environ[i][len] == '=')
  1546.         break;            /* strnEQ must come first to avoid */
  1547.     }                    /* potential SEGV's */
  1548.     return i;
  1549. }
  1550.  
  1551. #endif /* !VMS */
  1552.  
  1553. #ifdef UNLINK_ALL_VERSIONS
  1554. I32
  1555. unlnk(f)    /* unlink all versions of a file */
  1556. char *f;
  1557. {
  1558.     I32 i;
  1559.  
  1560.     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
  1561.     return i ? 0 : -1;
  1562. }
  1563. #endif
  1564.  
  1565. #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
  1566. char *
  1567. my_bcopy(register char *from,register char *to,register I32 len)
  1568. {
  1569.     char *retval = to;
  1570.  
  1571.     if (from - to >= 0) {
  1572.     while (len--)
  1573.         *to++ = *from++;
  1574.     }
  1575.     else {
  1576.     to += len;
  1577.     from += len;
  1578.     while (len--)
  1579.         *(--to) = *(--from);
  1580.     }
  1581.     return retval;
  1582. }
  1583. #endif
  1584.  
  1585. #ifndef HAS_MEMSET
  1586. void *
  1587. my_memset(loc,ch,len)
  1588. register char *loc;
  1589. register I32 ch;
  1590. register I32 len;
  1591. {
  1592.     char *retval = loc;
  1593.  
  1594.     while (len--)
  1595.     *loc++ = ch;
  1596.     return retval;
  1597. }
  1598. #endif
  1599.  
  1600. #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
  1601. char *
  1602. my_bzero(loc,len)
  1603. register char *loc;
  1604. register I32 len;
  1605. {
  1606.     char *retval = loc;
  1607.  
  1608.     while (len--)
  1609.     *loc++ = 0;
  1610.     return retval;
  1611. }
  1612. #endif
  1613.  
  1614. #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
  1615. I32
  1616. my_memcmp(s1,s2,len)
  1617. char *s1;
  1618. char *s2;
  1619. register I32 len;
  1620. {
  1621.     register U8 *a = (U8 *)s1;
  1622.     register U8 *b = (U8 *)s2;
  1623.     register I32 tmp;
  1624.  
  1625.     while (len--) {
  1626.     if (tmp = *a++ - *b++)
  1627.         return tmp;
  1628.     }
  1629.     return 0;
  1630. }
  1631. #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
  1632.  
  1633. #ifndef HAS_VPRINTF
  1634.  
  1635. #ifdef USE_CHAR_VSPRINTF
  1636. char *
  1637. #else
  1638. int
  1639. #endif
  1640. vsprintf(dest, pat, args)
  1641. char *dest;
  1642. const char *pat;
  1643. char *args;
  1644. {
  1645.     FILE fakebuf;
  1646.  
  1647.     fakebuf._ptr = dest;
  1648.     fakebuf._cnt = 32767;
  1649. #ifndef _IOSTRG
  1650. #define _IOSTRG 0
  1651. #endif
  1652.     fakebuf._flag = _IOWRT|_IOSTRG;
  1653.     _doprnt(pat, args, &fakebuf);    /* what a kludge */
  1654.     (void)putc('\0', &fakebuf);
  1655. #ifdef USE_CHAR_VSPRINTF
  1656.     return(dest);
  1657. #else
  1658.     return 0;        /* perl doesn't use return value */
  1659. #endif
  1660. }
  1661.  
  1662. #endif /* HAS_VPRINTF */
  1663.  
  1664. #ifdef MYSWAP
  1665. #if BYTEORDER != 0x4321
  1666. short
  1667. my_swap(short s)
  1668. {
  1669. #if (BYTEORDER & 1) == 0
  1670.     short result;
  1671.  
  1672.     result = ((s & 255) << 8) + ((s >> 8) & 255);
  1673.     return result;
  1674. #else
  1675.     return s;
  1676. #endif
  1677. }
  1678.  
  1679. long
  1680. my_htonl(long l)
  1681. {
  1682.     union {
  1683.     long result;
  1684.     char c[sizeof(long)];
  1685.     } u;
  1686.  
  1687. #if BYTEORDER == 0x1234
  1688.     u.c[0] = (l >> 24) & 255;
  1689.     u.c[1] = (l >> 16) & 255;
  1690.     u.c[2] = (l >> 8) & 255;
  1691.     u.c[3] = l & 255;
  1692.     return u.result;
  1693. #else
  1694. #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
  1695.     croak("Unknown BYTEORDER\n");
  1696. #else
  1697.     register I32 o;
  1698.     register I32 s;
  1699.  
  1700.     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
  1701.     u.c[o & 0xf] = (l >> s) & 255;
  1702.     }
  1703.     return u.result;
  1704. #endif
  1705. #endif
  1706. }
  1707.  
  1708. long
  1709. my_ntohl(long l)
  1710. {
  1711.     union {
  1712.     long l;
  1713.     char c[sizeof(long)];
  1714.     } u;
  1715.  
  1716. #if BYTEORDER == 0x1234
  1717.     u.c[0] = (l >> 24) & 255;
  1718.     u.c[1] = (l >> 16) & 255;
  1719.     u.c[2] = (l >> 8) & 255;
  1720.     u.c[3] = l & 255;
  1721.     return u.l;
  1722. #else
  1723. #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
  1724.     croak("Unknown BYTEORDER\n");
  1725. #else
  1726.     register I32 o;
  1727.     register I32 s;
  1728.  
  1729.     u.l = l;
  1730.     l = 0;
  1731.     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
  1732.     l |= (u.c[o & 0xf] & 255) << s;
  1733.     }
  1734.     return l;
  1735. #endif
  1736. #endif
  1737. }
  1738.  
  1739. #endif /* BYTEORDER != 0x4321 */
  1740. #endif /* MYSWAP */
  1741.  
  1742. /*
  1743.  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
  1744.  * If these functions are defined,
  1745.  * the BYTEORDER is neither 0x1234 nor 0x4321.
  1746.  * However, this is not assumed.
  1747.  * -DWS
  1748.  */
  1749.  
  1750. #define HTOV(name,type)                        \
  1751.     type                            \
  1752.     name (n)                        \
  1753.     register type n;                    \
  1754.     {                            \
  1755.         union {                        \
  1756.         type value;                    \
  1757.         char c[sizeof(type)];                \
  1758.         } u;                        \
  1759.         register I32 i;                    \
  1760.         register I32 s;                    \
  1761.         for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {    \
  1762.         u.c[i] = (n >> s) & 0xFF;            \
  1763.         }                            \
  1764.         return u.value;                    \
  1765.     }
  1766.  
  1767. #define VTOH(name,type)                        \
  1768.     type                            \
  1769.     name (n)                        \
  1770.     register type n;                    \
  1771.     {                            \
  1772.         union {                        \
  1773.         type value;                    \
  1774.         char c[sizeof(type)];                \
  1775.         } u;                        \
  1776.         register I32 i;                    \
  1777.         register I32 s;                    \
  1778.         u.value = n;                    \
  1779.         n = 0;                        \
  1780.         for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {    \
  1781.         n += (u.c[i] & 0xFF) << s;            \
  1782.         }                            \
  1783.         return n;                        \
  1784.     }
  1785.  
  1786. #if defined(HAS_HTOVS) && !defined(htovs)
  1787. HTOV(htovs,short)
  1788. #endif
  1789. #if defined(HAS_HTOVL) && !defined(htovl)
  1790. HTOV(htovl,long)
  1791. #endif
  1792. #if defined(HAS_VTOHS) && !defined(vtohs)
  1793. VTOH(vtohs,short)
  1794. #endif
  1795. #if defined(HAS_VTOHL) && !defined(vtohl)
  1796. VTOH(vtohl,long)
  1797. #endif
  1798.  
  1799.     /* VMS' my_popen() is in VMS.c, same with OS/2. */
  1800. #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
  1801. PerlIO *
  1802. my_popen(char *cmd, char *mode)
  1803. {
  1804.     int p[2];
  1805.     register I32 This, that;
  1806.     register I32 pid;
  1807.     SV *sv;
  1808.     I32 doexec = strNE(cmd,"-");
  1809.  
  1810. #ifdef OS2
  1811.     if (doexec) {
  1812.     return my_syspopen(cmd,mode);
  1813.     }
  1814. #endif 
  1815.     This = (*mode == 'w');
  1816.     that = !This;
  1817.     if (doexec && PL_tainting) {
  1818.     taint_env();
  1819.     taint_proper("Insecure %s%s", "EXEC");
  1820.     }
  1821.     if (PerlProc_pipe(p) < 0)
  1822.     return Nullfp;
  1823.     while ((pid = (doexec?vfork():fork())) < 0) {
  1824.     if (errno != EAGAIN) {
  1825.         PerlLIO_close(p[This]);
  1826.         if (!doexec)
  1827.         croak("Can't fork");
  1828.         return Nullfp;
  1829.     }
  1830.     sleep(5);
  1831.     }
  1832.     if (pid == 0) {
  1833.     GV* tmpgv;
  1834.  
  1835. #undef THIS
  1836. #undef THAT
  1837. #define THIS that
  1838. #define THAT This
  1839.     PerlLIO_close(p[THAT]);
  1840.     if (p[THIS] != (*mode == 'r')) {
  1841.         PerlLIO_dup2(p[THIS], *mode == 'r');
  1842.         PerlLIO_close(p[THIS]);
  1843.     }
  1844.     if (doexec) {
  1845. #if !defined(HAS_FCNTL) || !defined(F_SETFD)
  1846.         int fd;
  1847.  
  1848. #ifndef NOFILE
  1849. #define NOFILE 20
  1850. #endif
  1851.         for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
  1852.         PerlLIO_close(fd);
  1853. #endif
  1854.         do_exec(cmd);    /* may or may not use the shell */
  1855.         PerlProc__exit(1);
  1856.     }
  1857.     /*SUPPRESS 560*/
  1858.     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
  1859.         sv_setiv(GvSV(tmpgv), (IV)getpid());
  1860.     PL_forkprocess = 0;
  1861.     hv_clear(PL_pidstatus);    /* we have no children */
  1862.     return Nullfp;
  1863. #undef THIS
  1864. #undef THAT
  1865.     }
  1866.     do_execfree();    /* free any memory malloced by child on vfork */
  1867.     PerlLIO_close(p[that]);
  1868.     if (p[that] < p[This]) {
  1869.     PerlLIO_dup2(p[This], p[that]);
  1870.     PerlLIO_close(p[This]);
  1871.     p[This] = p[that];
  1872.     }
  1873.     sv = *av_fetch(PL_fdpid,p[This],TRUE);
  1874.     (void)SvUPGRADE(sv,SVt_IV);
  1875.     SvIVX(sv) = pid;
  1876.     PL_forkprocess = pid;
  1877.     return PerlIO_fdopen(p[This], mode);
  1878. }
  1879. #else
  1880. #if defined(atarist) || defined(DJGPP)
  1881. FILE *popen();
  1882. PerlIO *
  1883. my_popen(cmd,mode)
  1884. char    *cmd;
  1885. char    *mode;
  1886. {
  1887.     /* Needs work for PerlIO ! */
  1888.     /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
  1889.     return popen(PerlIO_exportFILE(cmd, 0), mode);
  1890. }
  1891. #endif
  1892.  
  1893. #endif /* !DOSISH */
  1894.  
  1895. #ifdef DUMP_FDS
  1896. void
  1897. dump_fds(char *s)
  1898. {
  1899.     int fd;
  1900.     struct stat tmpstatbuf;
  1901.  
  1902.     PerlIO_printf(PerlIO_stderr(),"%s", s);
  1903.     for (fd = 0; fd < 32; fd++) {
  1904.     if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
  1905.         PerlIO_printf(PerlIO_stderr()," %d",fd);
  1906.     }
  1907.     PerlIO_printf(PerlIO_stderr(),"\n");
  1908. }
  1909. #endif    /* DUMP_FDS */
  1910.  
  1911. #ifndef HAS_DUP2
  1912. int
  1913. dup2(oldfd,newfd)
  1914. int oldfd;
  1915. int newfd;
  1916. {
  1917. #if defined(HAS_FCNTL) && defined(F_DUPFD)
  1918.     if (oldfd == newfd)
  1919.     return oldfd;
  1920.     PerlLIO_close(newfd);
  1921.     return fcntl(oldfd, F_DUPFD, newfd);
  1922. #else
  1923. #define DUP2_MAX_FDS 256
  1924.     int fdtmp[DUP2_MAX_FDS];
  1925.     I32 fdx = 0;
  1926.     int fd;
  1927.  
  1928.     if (oldfd == newfd)
  1929.     return oldfd;
  1930.     PerlLIO_close(newfd);
  1931.     /* good enough for low fd's... */
  1932.     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
  1933.     if (fdx >= DUP2_MAX_FDS) {
  1934.         PerlLIO_close(fd);
  1935.         fd = -1;
  1936.         break;
  1937.     }
  1938.     fdtmp[fdx++] = fd;
  1939.     }
  1940.     while (fdx > 0)
  1941.     PerlLIO_close(fdtmp[--fdx]);
  1942.     return fd;
  1943. #endif
  1944. }
  1945. #endif
  1946.  
  1947.  
  1948. #ifdef HAS_SIGACTION
  1949.  
  1950. Sighandler_t
  1951. rsignal(int signo, Sighandler_t handler)
  1952. {
  1953.     struct sigaction act, oact;
  1954.  
  1955.     act.sa_handler = handler;
  1956.     sigemptyset(&act.sa_mask);
  1957.     act.sa_flags = 0;
  1958. #ifdef SA_RESTART
  1959.     act.sa_flags |= SA_RESTART;    /* SVR4, 4.3+BSD */
  1960. #endif
  1961. #ifdef SA_NOCLDWAIT
  1962.     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
  1963.     act.sa_flags |= SA_NOCLDWAIT;
  1964. #endif
  1965.     if (sigaction(signo, &act, &oact) == -1)
  1966.         return SIG_ERR;
  1967.     else
  1968.         return oact.sa_handler;
  1969. }
  1970.  
  1971. Sighandler_t
  1972. rsignal_state(int signo)
  1973. {
  1974.     struct sigaction oact;
  1975.  
  1976.     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
  1977.         return SIG_ERR;
  1978.     else
  1979.         return oact.sa_handler;
  1980. }
  1981.  
  1982. int
  1983. rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
  1984. {
  1985.     struct sigaction act;
  1986.  
  1987.     act.sa_handler = handler;
  1988.     sigemptyset(&act.sa_mask);
  1989.     act.sa_flags = 0;
  1990. #ifdef SA_RESTART
  1991.     act.sa_flags |= SA_RESTART;    /* SVR4, 4.3+BSD */
  1992. #endif
  1993. #ifdef SA_NOCLDWAIT
  1994.     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
  1995.     act.sa_flags |= SA_NOCLDWAIT;
  1996. #endif
  1997.     return sigaction(signo, &act, save);
  1998. }
  1999.  
  2000. int
  2001. rsignal_restore(int signo, Sigsave_t *save)
  2002. {
  2003.     return sigaction(signo, save, (struct sigaction *)NULL);
  2004. }
  2005.  
  2006. #else /* !HAS_SIGACTION */
  2007.  
  2008. Sighandler_t
  2009. rsignal(int signo, Sighandler_t handler)
  2010. {
  2011.     return PerlProc_signal(signo, handler);
  2012. }
  2013.  
  2014. static int sig_trapped;
  2015.  
  2016. static
  2017. Signal_t
  2018. sig_trap(int signo)
  2019. {
  2020.     sig_trapped++;
  2021. }
  2022.  
  2023. Sighandler_t
  2024. rsignal_state(int signo)
  2025. {
  2026.     Sighandler_t oldsig;
  2027.  
  2028.     sig_trapped = 0;
  2029.     oldsig = PerlProc_signal(signo, sig_trap);
  2030.     PerlProc_signal(signo, oldsig);
  2031.     if (sig_trapped)
  2032.         PerlProc_kill(getpid(), signo);
  2033.     return oldsig;
  2034. }
  2035.  
  2036. int
  2037. rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
  2038. {
  2039.     *save = PerlProc_signal(signo, handler);
  2040.     return (*save == SIG_ERR) ? -1 : 0;
  2041. }
  2042.  
  2043. int
  2044. rsignal_restore(int signo, Sigsave_t *save)
  2045. {
  2046.     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
  2047. }
  2048.  
  2049. #endif /* !HAS_SIGACTION */
  2050.  
  2051.     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
  2052. #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
  2053. I32
  2054. my_pclose(PerlIO *ptr)
  2055. {
  2056.     Sigsave_t hstat, istat, qstat;
  2057.     int status;
  2058.     SV **svp;
  2059.     int pid;
  2060.     int pid2;
  2061.     bool close_failed;
  2062.     int saved_errno;
  2063. #ifdef VMS
  2064.     int saved_vaxc_errno;
  2065. #endif
  2066. #ifdef WIN32
  2067.     int saved_win32_errno;
  2068. #endif
  2069.  
  2070.     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
  2071.     pid = (int)SvIVX(*svp);
  2072.     SvREFCNT_dec(*svp);
  2073.     *svp = &PL_sv_undef;
  2074. #ifdef OS2
  2075.     if (pid == -1) {            /* Opened by popen. */
  2076.     return my_syspclose(ptr);
  2077.     }
  2078. #endif 
  2079.     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
  2080.     saved_errno = errno;
  2081. #ifdef VMS
  2082.     saved_vaxc_errno = vaxc$errno;
  2083. #endif
  2084. #ifdef WIN32
  2085.     saved_win32_errno = GetLastError();
  2086. #endif
  2087.     }
  2088. #ifdef UTS
  2089.     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
  2090. #endif
  2091.     rsignal_save(SIGHUP, SIG_IGN, &hstat);
  2092.     rsignal_save(SIGINT, SIG_IGN, &istat);
  2093.     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
  2094.     do {
  2095.     pid2 = wait4pid(pid, &status, 0);
  2096.     } while (pid2 == -1 && errno == EINTR);
  2097.     rsignal_restore(SIGHUP, &hstat);
  2098.     rsignal_restore(SIGINT, &istat);
  2099.     rsignal_restore(SIGQUIT, &qstat);
  2100.     if (close_failed) {
  2101.     SETERRNO(saved_errno, saved_vaxc_errno);
  2102.     return -1;
  2103.     }
  2104.     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
  2105. }
  2106. #endif /* !DOSISH */
  2107.  
  2108. #if  !defined(DOSISH) || defined(OS2) || defined(WIN32)
  2109. I32
  2110. wait4pid(int pid, int *statusp, int flags)
  2111. {
  2112.     SV *sv;
  2113.     SV** svp;
  2114.     char spid[TYPE_CHARS(int)];
  2115.  
  2116.     if (!pid)
  2117.     return -1;
  2118.     if (pid > 0) {
  2119.     sprintf(spid, "%d", pid);
  2120.     svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
  2121.     if (svp && *svp != &PL_sv_undef) {
  2122.         *statusp = SvIVX(*svp);
  2123.         (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
  2124.         return pid;
  2125.     }
  2126.     }
  2127.     else {
  2128.     HE *entry;
  2129.  
  2130.     hv_iterinit(PL_pidstatus);
  2131.     if (entry = hv_iternext(PL_pidstatus)) {
  2132.         pid = atoi(hv_iterkey(entry,(I32*)statusp));
  2133.         sv = hv_iterval(PL_pidstatus,entry);
  2134.         *statusp = SvIVX(sv);
  2135.         sprintf(spid, "%d", pid);
  2136.         (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
  2137.         return pid;
  2138.     }
  2139.     }
  2140. #ifdef HAS_WAITPID
  2141. #  ifdef HAS_WAITPID_RUNTIME
  2142.     if (!HAS_WAITPID_RUNTIME)
  2143.     goto hard_way;
  2144. #  endif
  2145.     return PerlProc_waitpid(pid,statusp,flags);
  2146. #endif
  2147. #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
  2148.     return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
  2149. #endif
  2150. #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
  2151.   hard_way:
  2152.     {
  2153.     I32 result;
  2154.     if (flags)
  2155.         croak("Can't do waitpid with flags");
  2156.     else {
  2157.         while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
  2158.         pidgone(result,*statusp);
  2159.         if (result < 0)
  2160.         *statusp = -1;
  2161.     }
  2162.     return result;
  2163.     }
  2164. #endif
  2165. }
  2166. #endif /* !DOSISH || OS2 || WIN32 */
  2167.  
  2168. void
  2169. /*SUPPRESS 590*/
  2170. pidgone(int pid, int status)
  2171. {
  2172.     register SV *sv;
  2173.     char spid[TYPE_CHARS(int)];
  2174.  
  2175.     sprintf(spid, "%d", pid);
  2176.     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
  2177.     (void)SvUPGRADE(sv,SVt_IV);
  2178.     SvIVX(sv) = status;
  2179.     return;
  2180. }
  2181.  
  2182. #if defined(atarist) || defined(OS2) || defined(DJGPP)
  2183. int pclose();
  2184. #ifdef HAS_FORK
  2185. int                    /* Cannot prototype with I32
  2186.                        in os2ish.h. */
  2187. my_syspclose(ptr)
  2188. #else
  2189. I32
  2190. my_pclose(ptr)
  2191. #endif 
  2192. PerlIO *ptr;
  2193. {
  2194.     /* Needs work for PerlIO ! */
  2195.     FILE *f = PerlIO_findFILE(ptr);
  2196.     I32 result = pclose(f);
  2197.     PerlIO_releaseFILE(ptr,f);
  2198.     return result;
  2199. }
  2200. #endif
  2201.  
  2202. void
  2203. repeatcpy(register char *to, register char *from, I32 len, register I32 count)
  2204. {
  2205.     register I32 todo;
  2206.     register char *frombase = from;
  2207.  
  2208.     if (len == 1) {
  2209.     todo = *from;
  2210.     while (count-- > 0)
  2211.         *to++ = todo;
  2212.     return;
  2213.     }
  2214.     while (count-- > 0) {
  2215.     for (todo = len; todo > 0; todo--) {
  2216.         *to++ = *from++;
  2217.     }
  2218.     from = frombase;
  2219.     }
  2220. }
  2221.  
  2222. #ifndef CASTNEGFLOAT
  2223. U32
  2224. cast_ulong(f)
  2225. double f;
  2226. {
  2227.     long along;
  2228.  
  2229. #if CASTFLAGS & 2
  2230. #   define BIGDOUBLE 2147483648.0
  2231.     if (f >= BIGDOUBLE)
  2232.     return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
  2233. #endif
  2234.     if (f >= 0.0)
  2235.     return (unsigned long)f;
  2236.     along = (long)f;
  2237.     return (unsigned long)along;
  2238. }
  2239. # undef BIGDOUBLE
  2240. #endif
  2241.  
  2242. #ifndef CASTI32
  2243.  
  2244. /* Unfortunately, on some systems the cast_uv() function doesn't
  2245.    work with the system-supplied definition of ULONG_MAX.  The
  2246.    comparison  (f >= ULONG_MAX) always comes out true.  It must be a
  2247.    problem with the compiler constant folding.
  2248.  
  2249.    In any case, this workaround should be fine on any two's complement
  2250.    system.  If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
  2251.    ccflags.
  2252.            --Andy Dougherty      <doughera@lafcol.lafayette.edu>
  2253. */
  2254.  
  2255. /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
  2256.    of LONG_(MIN/MAX).
  2257.                            -- Kenneth Albanowski <kjahds@kjahds.com>
  2258. */                                      
  2259.  
  2260. #ifndef MY_UV_MAX
  2261. #  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
  2262. #endif
  2263.  
  2264. I32
  2265. cast_i32(f)
  2266. double f;
  2267. {
  2268.     if (f >= I32_MAX)
  2269.     return (I32) I32_MAX;
  2270.     if (f <= I32_MIN)
  2271.     return (I32) I32_MIN;
  2272.     return (I32) f;
  2273. }
  2274.  
  2275. IV
  2276. cast_iv(f)
  2277. double f;
  2278. {
  2279.     if (f >= IV_MAX)
  2280.     return (IV) IV_MAX;
  2281.     if (f <= IV_MIN)
  2282.     return (IV) IV_MIN;
  2283.     return (IV) f;
  2284. }
  2285.  
  2286. UV
  2287. cast_uv(f)
  2288. double f;
  2289. {
  2290.     if (f >= MY_UV_MAX)
  2291.     return (UV) MY_UV_MAX;
  2292.     return (UV) f;
  2293. }
  2294.  
  2295. #endif
  2296.  
  2297. #ifndef HAS_RENAME
  2298. I32
  2299. same_dirent(a,b)
  2300. char *a;
  2301. char *b;
  2302. {
  2303.     char *fa = strrchr(a,'/');
  2304.     char *fb = strrchr(b,'/');
  2305.     struct stat tmpstatbuf1;
  2306.     struct stat tmpstatbuf2;
  2307.     SV *tmpsv = sv_newmortal();
  2308.  
  2309.     if (fa)
  2310.     fa++;
  2311.     else
  2312.     fa = a;
  2313.     if (fb)
  2314.     fb++;
  2315.     else
  2316.     fb = b;
  2317.     if (strNE(a,b))
  2318.     return FALSE;
  2319.     if (fa == a)
  2320.     sv_setpv(tmpsv, ".");
  2321.     else
  2322.     sv_setpvn(tmpsv, a, fa - a);
  2323.     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
  2324.     return FALSE;
  2325.     if (fb == b)
  2326.     sv_setpv(tmpsv, ".");
  2327.     else
  2328.     sv_setpvn(tmpsv, b, fb - b);
  2329.     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
  2330.     return FALSE;
  2331.     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
  2332.        tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
  2333. }
  2334. #endif /* !HAS_RENAME */
  2335.  
  2336. UV
  2337. scan_oct(char *start, I32 len, I32 *retlen)
  2338. {
  2339.     register char *s = start;
  2340.     register UV retval = 0;
  2341.     bool overflowed = FALSE;
  2342.  
  2343.     while (len && *s >= '0' && *s <= '7') {
  2344.     register UV n = retval << 3;
  2345.     if (!overflowed && (n >> 3) != retval) {
  2346.         warn("Integer overflow in octal number");
  2347.         overflowed = TRUE;
  2348.     }
  2349.     retval = n | (*s++ - '0');
  2350.     len--;
  2351.     }
  2352.     if (PL_dowarn && len && (*s == '8' || *s == '9'))
  2353.     warn("Illegal octal digit ignored");
  2354.     *retlen = s - start;
  2355.     return retval;
  2356. }
  2357.  
  2358. UV
  2359. scan_hex(char *start, I32 len, I32 *retlen)
  2360. {
  2361.     register char *s = start;
  2362.     register UV retval = 0;
  2363.     bool overflowed = FALSE;
  2364.     char *tmp = s;
  2365.  
  2366.     while (len-- && *s && (tmp = strchr((char *) PL_hexdigit, *s))) {
  2367.     register UV n = retval << 4;
  2368.     if (!overflowed && (n >> 4) != retval) {
  2369.         warn("Integer overflow in hex number");
  2370.         overflowed = TRUE;
  2371.     }
  2372.     retval = n | ((tmp - PL_hexdigit) & 15);
  2373.     s++;
  2374.     }
  2375.     if (PL_dowarn && !tmp) {
  2376.     warn("Illegal hex digit ignored");
  2377.     }
  2378.     *retlen = s - start;
  2379.     return retval;
  2380. }
  2381.  
  2382. char*
  2383. find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
  2384. {
  2385.     dTHR;
  2386.     char *xfound = Nullch;
  2387.     char *xfailed = Nullch;
  2388.     char tmpbuf[512];
  2389.     register char *s;
  2390.     I32 len;
  2391.     int retval;
  2392. #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
  2393. #  define SEARCH_EXTS ".bat", ".cmd", NULL
  2394. #  define MAX_EXT_LEN 4
  2395. #endif
  2396. #ifdef OS2
  2397. #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
  2398. #  define MAX_EXT_LEN 4
  2399. #endif
  2400. #ifdef VMS
  2401. #  define SEARCH_EXTS ".pl", ".com", NULL
  2402. #  define MAX_EXT_LEN 4
  2403. #endif
  2404.     /* additional extensions to try in each dir if scriptname not found */
  2405. #ifdef SEARCH_EXTS
  2406.     char *exts[] = { SEARCH_EXTS };
  2407.     char **ext = search_ext ? search_ext : exts;
  2408.     int extidx = 0, i = 0;
  2409.     char *curext = Nullch;
  2410. #else
  2411. #  define MAX_EXT_LEN 0
  2412. #endif
  2413.  
  2414.     /*
  2415.      * If dosearch is true and if scriptname does not contain path
  2416.      * delimiters, search the PATH for scriptname.
  2417.      *
  2418.      * If SEARCH_EXTS is also defined, will look for each
  2419.      * scriptname{SEARCH_EXTS} whenever scriptname is not found
  2420.      * while searching the PATH.
  2421.      *
  2422.      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
  2423.      * proceeds as follows:
  2424.      *   If DOSISH or VMSISH:
  2425.      *     + look for ./scriptname{,.foo,.bar}
  2426.      *     + search the PATH for scriptname{,.foo,.bar}
  2427.      *
  2428.      *   If !DOSISH:
  2429.      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
  2430.      *       this will not look in '.' if it's not in the PATH)
  2431.      */
  2432.     tmpbuf[0] = '\0';
  2433.  
  2434. #ifdef VMS
  2435. #  ifdef ALWAYS_DEFTYPES
  2436.     len = strlen(scriptname);
  2437.     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
  2438.     int hasdir, idx = 0, deftypes = 1;
  2439.     bool seen_dot = 1;
  2440.  
  2441.     hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
  2442. #  else
  2443.     if (dosearch) {
  2444.     int hasdir, idx = 0, deftypes = 1;
  2445.     bool seen_dot = 1;
  2446.  
  2447.     hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
  2448. #  endif
  2449.     /* The first time through, just add SEARCH_EXTS to whatever we
  2450.      * already have, so we can check for default file types. */
  2451.     while (deftypes ||
  2452.            (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
  2453.     {
  2454.         if (deftypes) {
  2455.         deftypes = 0;
  2456.         *tmpbuf = '\0';
  2457.         }
  2458.         if ((strlen(tmpbuf) + strlen(scriptname)
  2459.          + MAX_EXT_LEN) >= sizeof tmpbuf)
  2460.         continue;    /* don't search dir with too-long name */
  2461.         strcat(tmpbuf, scriptname);
  2462. #else  /* !VMS */
  2463.  
  2464. #ifdef DOSISH
  2465.     if (strEQ(scriptname, "-"))
  2466.      dosearch = 0;
  2467.     if (dosearch) {        /* Look in '.' first. */
  2468.     char *cur = scriptname;
  2469. #ifdef SEARCH_EXTS
  2470.     if ((curext = strrchr(scriptname,'.')))    /* possible current ext */
  2471.         while (ext[i])
  2472.         if (strEQ(ext[i++],curext)) {
  2473.             extidx = -1;        /* already has an ext */
  2474.             break;
  2475.         }
  2476.     do {
  2477. #endif
  2478.         DEBUG_p(PerlIO_printf(Perl_debug_log,
  2479.                   "Looking for %s\n",cur));
  2480.         if (PerlLIO_stat(cur,&PL_statbuf) >= 0) {
  2481.         dosearch = 0;
  2482.         scriptname = cur;
  2483. #ifdef SEARCH_EXTS
  2484.         break;
  2485. #endif
  2486.         }
  2487. #ifdef SEARCH_EXTS
  2488.         if (cur == scriptname) {
  2489.         len = strlen(scriptname);
  2490.         if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
  2491.             break;
  2492.         cur = strcpy(tmpbuf, scriptname);
  2493.         }
  2494.     } while (extidx >= 0 && ext[extidx]    /* try an extension? */
  2495.          && strcpy(tmpbuf+len, ext[extidx++]));
  2496. #endif
  2497.     }
  2498. #endif
  2499.  
  2500.     if (dosearch && !strchr(scriptname, '/')
  2501. #ifdef DOSISH
  2502.          && !strchr(scriptname, '\\')
  2503. #endif
  2504.          && (s = PerlEnv_getenv("PATH"))) {
  2505.     bool seen_dot = 0;
  2506.     
  2507.     PL_bufend = s + strlen(s);
  2508.     while (s < PL_bufend) {
  2509. #if defined(atarist) || defined(DOSISH)
  2510.         for (len = 0; *s
  2511. #  ifdef atarist
  2512.             && *s != ','
  2513. #  endif
  2514.             && *s != ';'; len++, s++) {
  2515.         if (len < sizeof tmpbuf)
  2516.             tmpbuf[len] = *s;
  2517.         }
  2518.         if (len < sizeof tmpbuf)
  2519.         tmpbuf[len] = '\0';
  2520. #else  /* ! (atarist || DOSISH) */
  2521.         s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
  2522.             ':',
  2523.             &len);
  2524. #endif /* ! (atarist || DOSISH) */
  2525.         if (s < PL_bufend)
  2526.         s++;
  2527.         if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
  2528.         continue;    /* don't search dir with too-long name */
  2529.         if (len
  2530. #if defined(atarist) || defined(DOSISH)
  2531.         && tmpbuf[len - 1] != '/'
  2532.         && tmpbuf[len - 1] != '\\'
  2533. #endif
  2534.            )
  2535.         tmpbuf[len++] = '/';
  2536.         if (len == 2 && tmpbuf[0] == '.')
  2537.         seen_dot = 1;
  2538.         (void)strcpy(tmpbuf + len, scriptname);
  2539. #endif  /* !VMS */
  2540.  
  2541. #ifdef SEARCH_EXTS
  2542.         len = strlen(tmpbuf);
  2543.         if (extidx > 0)    /* reset after previous loop */
  2544.         extidx = 0;
  2545.         do {
  2546. #endif
  2547.             DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
  2548.         retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
  2549. #ifdef SEARCH_EXTS
  2550.         } while (  retval < 0        /* not there */
  2551.             && extidx>=0 && ext[extidx]    /* try an extension? */
  2552.             && strcpy(tmpbuf+len, ext[extidx++])
  2553.         );
  2554. #endif
  2555.         if (retval < 0)
  2556.         continue;
  2557.         if (S_ISREG(PL_statbuf.st_mode)
  2558.         && cando(S_IRUSR,TRUE,&PL_statbuf)
  2559. #ifndef DOSISH
  2560.         && cando(S_IXUSR,TRUE,&PL_statbuf)
  2561. #endif
  2562.         )
  2563.         {
  2564.         xfound = tmpbuf;              /* bingo! */
  2565.         break;
  2566.         }
  2567.         if (!xfailed)
  2568.         xfailed = savepv(tmpbuf);
  2569.     }
  2570. #ifndef DOSISH
  2571.     if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0))
  2572. #endif
  2573.         seen_dot = 1;            /* Disable message. */
  2574.     if (!xfound) {
  2575.         if (flags & 1) {            /* do or die? */
  2576.             croak("Can't %s %s%s%s",
  2577.               (xfailed ? "execute" : "find"),
  2578.               (xfailed ? xfailed : scriptname),
  2579.               (xfailed ? "" : " on PATH"),
  2580.               (xfailed || seen_dot) ? "" : ", '.' not in PATH");
  2581.         }
  2582.         scriptname = Nullch;
  2583.     }
  2584.     if (xfailed)
  2585.         Safefree(xfailed);
  2586.     scriptname = xfound;
  2587.     }
  2588.     return (scriptname ? savepv(scriptname) : Nullch);
  2589. }
  2590.  
  2591.  
  2592. #ifdef USE_THREADS
  2593. #ifdef FAKE_THREADS
  2594. /* Very simplistic scheduler for now */
  2595. void
  2596. schedule(void)
  2597. {
  2598.     thr = thr->i.next_run;
  2599. }
  2600.  
  2601. void
  2602. perl_cond_init(cp)
  2603. perl_cond *cp;
  2604. {
  2605.     *cp = 0;
  2606. }
  2607.  
  2608. void
  2609. perl_cond_signal(cp)
  2610. perl_cond *cp;
  2611. {
  2612.     perl_os_thread t;
  2613.     perl_cond cond = *cp;
  2614.     
  2615.     if (!cond)
  2616.     return;
  2617.     t = cond->thread;
  2618.     /* Insert t in the runnable queue just ahead of us */
  2619.     t->i.next_run = thr->i.next_run;
  2620.     thr->i.next_run->i.prev_run = t;
  2621.     t->i.prev_run = thr;
  2622.     thr->i.next_run = t;
  2623.     thr->i.wait_queue = 0;
  2624.     /* Remove from the wait queue */
  2625.     *cp = cond->next;
  2626.     Safefree(cond);
  2627. }
  2628.  
  2629. void
  2630. perl_cond_broadcast(cp)
  2631. perl_cond *cp;
  2632. {
  2633.     perl_os_thread t;
  2634.     perl_cond cond, cond_next;
  2635.     
  2636.     for (cond = *cp; cond; cond = cond_next) {
  2637.     t = cond->thread;
  2638.     /* Insert t in the runnable queue just ahead of us */
  2639.     t->i.next_run = thr->i.next_run;
  2640.     thr->i.next_run->i.prev_run = t;
  2641.     t->i.prev_run = thr;
  2642.     thr->i.next_run = t;
  2643.     thr->i.wait_queue = 0;
  2644.     /* Remove from the wait queue */
  2645.     cond_next = cond->next;
  2646.     Safefree(cond);
  2647.     }
  2648.     *cp = 0;
  2649. }
  2650.  
  2651. void
  2652. perl_cond_wait(cp)
  2653. perl_cond *cp;
  2654. {
  2655.     perl_cond cond;
  2656.  
  2657.     if (thr->i.next_run == thr)
  2658.     croak("panic: perl_cond_wait called by last runnable thread");
  2659.     
  2660.     New(666, cond, 1, struct perl_wait_queue);
  2661.     cond->thread = thr;
  2662.     cond->next = *cp;
  2663.     *cp = cond;
  2664.     thr->i.wait_queue = cond;
  2665.     /* Remove ourselves from runnable queue */
  2666.     thr->i.next_run->i.prev_run = thr->i.prev_run;
  2667.     thr->i.prev_run->i.next_run = thr->i.next_run;
  2668. }
  2669. #endif /* FAKE_THREADS */
  2670.  
  2671. #ifdef OLD_PTHREADS_API
  2672. struct perl_thread *
  2673. getTHR _((void))
  2674. {
  2675.     pthread_addr_t t;
  2676.  
  2677.     if (pthread_getspecific(PL_thr_key, &t))
  2678.     croak("panic: pthread_getspecific");
  2679.     return (struct perl_thread *) t;
  2680. }
  2681. #endif /* OLD_PTHREADS_API */
  2682.  
  2683. MAGIC *
  2684. condpair_magic(SV *sv)
  2685. {
  2686.     MAGIC *mg;
  2687.     
  2688.     SvUPGRADE(sv, SVt_PVMG);
  2689.     mg = mg_find(sv, 'm');
  2690.     if (!mg) {
  2691.     condpair_t *cp;
  2692.  
  2693.     New(53, cp, 1, condpair_t);
  2694.     MUTEX_INIT(&cp->mutex);
  2695.     COND_INIT(&cp->owner_cond);
  2696.     COND_INIT(&cp->cond);
  2697.     cp->owner = 0;
  2698.     LOCK_SV_MUTEX;
  2699.     mg = mg_find(sv, 'm');
  2700.     if (mg) {
  2701.         /* someone else beat us to initialising it */
  2702.         UNLOCK_SV_MUTEX;
  2703.         MUTEX_DESTROY(&cp->mutex);
  2704.         COND_DESTROY(&cp->owner_cond);
  2705.         COND_DESTROY(&cp->cond);
  2706.         Safefree(cp);
  2707.     }
  2708.     else {
  2709.         sv_magic(sv, Nullsv, 'm', 0, 0);
  2710.         mg = SvMAGIC(sv);
  2711.         mg->mg_ptr = (char *)cp;
  2712.         mg->mg_len = sizeof(cp);
  2713.         UNLOCK_SV_MUTEX;
  2714.         DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
  2715.                        "%p: condpair_magic %p\n", thr, sv));)
  2716.     }
  2717.     }
  2718.     return mg;
  2719. }
  2720.  
  2721. /*
  2722.  * Make a new perl thread structure using t as a prototype. Some of the
  2723.  * fields for the new thread are copied from the prototype thread, t,
  2724.  * so t should not be running in perl at the time this function is
  2725.  * called. The use by ext/Thread/Thread.xs in core perl (where t is the
  2726.  * thread calling new_struct_thread) clearly satisfies this constraint.
  2727.  */
  2728. struct perl_thread *
  2729. new_struct_thread(struct perl_thread *t)
  2730. {
  2731.     struct perl_thread *thr;
  2732.     SV *sv;
  2733.     SV **svp;
  2734.     I32 i;
  2735.  
  2736.     sv = newSVpv("", 0);
  2737.     SvGROW(sv, sizeof(struct perl_thread) + 1);
  2738.     SvCUR_set(sv, sizeof(struct perl_thread));
  2739.     thr = (Thread) SvPVX(sv);
  2740.     /* debug */
  2741.     memset(thr, 0xab, sizeof(struct perl_thread));
  2742.     PL_markstack = 0;
  2743.     PL_scopestack = 0;
  2744.     PL_savestack = 0;
  2745.     PL_retstack = 0;
  2746.     PL_dirty = 0;
  2747.     PL_localizing = 0;
  2748.     /* end debug */
  2749.  
  2750.     thr->oursv = sv;
  2751.     init_stacks(ARGS);
  2752.  
  2753.     PL_curcop = &PL_compiling;
  2754.     thr->cvcache = newHV();
  2755.     thr->threadsv = newAV();
  2756.     thr->specific = newAV();
  2757.     thr->errsv = newSVpv("", 0);
  2758.     thr->errhv = newHV();
  2759.     thr->flags = THRf_R_JOINABLE;
  2760.     MUTEX_INIT(&thr->mutex);
  2761.  
  2762.     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
  2763.     PL_defstash = t->Tdefstash;   /* XXX maybe these should */
  2764.     PL_curstash = t->Tcurstash;   /* always be set to main? */
  2765.  
  2766.  
  2767.     /* top_env needs to be non-zero. It points to an area
  2768.        in which longjmp() stuff is stored, as C callstack
  2769.        info there at least is thread specific this has to
  2770.        be per-thread. Otherwise a 'die' in a thread gives
  2771.        that thread the C stack of last thread to do an eval {}!
  2772.        See comments in scope.h    
  2773.        Initialize top entry (as in perl.c for main thread)
  2774.      */
  2775.     PL_start_env.je_prev = NULL;
  2776.     PL_start_env.je_ret = -1;
  2777.     PL_start_env.je_mustcatch = TRUE;
  2778.     PL_top_env  = &PL_start_env;
  2779.  
  2780.     PL_in_eval = FALSE;
  2781.     PL_restartop = 0;
  2782.  
  2783.     PL_tainted = t->Ttainted;
  2784.     PL_curpm = t->Tcurpm;         /* XXX No PMOP ref count */
  2785.     PL_nrs = newSVsv(t->Tnrs);
  2786.     PL_rs = SvREFCNT_inc(PL_nrs);
  2787.     PL_last_in_gv = Nullgv;
  2788.     PL_ofslen = t->Tofslen;
  2789.     PL_ofs = savepvn(t->Tofs, PL_ofslen);
  2790.     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
  2791.     PL_chopset = t->Tchopset;
  2792.     PL_formtarget = newSVsv(t->Tformtarget);
  2793.     PL_bodytarget = newSVsv(t->Tbodytarget);
  2794.     PL_toptarget = newSVsv(t->Ttoptarget);
  2795.  
  2796.     PL_statname = NEWSV(66,0);
  2797.     PL_maxscream = -1;
  2798.     PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
  2799.     PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
  2800.     PL_regindent = 0;
  2801.     PL_reginterp_cnt = 0;
  2802.     PL_lastscream = Nullsv;
  2803.     PL_screamfirst = 0;
  2804.     PL_screamnext = 0;
  2805.     PL_reg_start_tmp = 0;
  2806.     PL_reg_start_tmpl = 0;
  2807.     
  2808.     /* Initialise all per-thread SVs that the template thread used */
  2809.     svp = AvARRAY(t->threadsv);
  2810.     for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
  2811.     if (*svp && *svp != &PL_sv_undef) {
  2812.         SV *sv = newSVsv(*svp);
  2813.         av_store(thr->threadsv, i, sv);
  2814.         sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
  2815.         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
  2816.         "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
  2817.     }
  2818.     } 
  2819.     thr->threadsvp = AvARRAY(thr->threadsv);
  2820.  
  2821.     MUTEX_LOCK(&PL_threads_mutex);
  2822.     PL_nthreads++;
  2823.     thr->tid = ++PL_threadnum;
  2824.     thr->next = t->next;
  2825.     thr->prev = t;
  2826.     t->next = thr;
  2827.     thr->next->prev = thr;
  2828.     MUTEX_UNLOCK(&PL_threads_mutex);
  2829.  
  2830. #ifdef HAVE_THREAD_INTERN
  2831.     init_thread_intern(thr);
  2832. #endif /* HAVE_THREAD_INTERN */
  2833.     return thr;
  2834. }
  2835. #endif /* USE_THREADS */
  2836.  
  2837. #ifdef HUGE_VAL
  2838. /*
  2839.  * This hack is to force load of "huge" support from libm.a
  2840.  * So it is in perl for (say) POSIX to use. 
  2841.  * Needed for SunOS with Sun's 'acc' for example.
  2842.  */
  2843. double 
  2844. Perl_huge(void)
  2845. {
  2846.  return HUGE_VAL;
  2847. }
  2848. #endif
  2849.  
  2850. #ifdef PERL_GLOBAL_STRUCT
  2851. struct perl_vars *
  2852. Perl_GetVars(void)
  2853. {
  2854.  return &PL_Vars;
  2855. }
  2856. #endif
  2857.  
  2858. char **
  2859. get_op_names(void)
  2860. {
  2861.  return op_name;
  2862. }
  2863.  
  2864. char **
  2865. get_op_descs(void)
  2866. {
  2867.  return op_desc;
  2868. }
  2869.  
  2870. char *
  2871. get_no_modify(void)
  2872. {
  2873.  return (char*)no_modify;
  2874. }
  2875.  
  2876. U32 *
  2877. get_opargs(void)
  2878. {
  2879.  return opargs;
  2880. }
  2881.  
  2882.  
  2883. SV **
  2884. get_specialsv_list(void)
  2885. {
  2886.  return PL_specialsv_list;
  2887. }
  2888.